home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / src / read.c < prev    next >
C/C++ Source or Header  |  1992-11-15  |  13KB  |  562 lines
  1. #include <ctype.h>
  2.  
  3. #include "scheme.h"
  4.  
  5. extern char *index();
  6. extern double atof();
  7.  
  8. Object Sym_Quote,
  9.        Sym_Quasiquote,
  10.        Sym_Unquote,
  11.        Sym_Unquote_Splicing;
  12.  
  13. #define GETC    {\
  14.     c = str ? String_Getc (port) : getc (f);\
  15.     if (c == '\n') PORT(port)->lno++;\
  16. }
  17. #define UNGETC  {\
  18.     if (str) String_Ungetc (port,c); else (void)ungetc (c,f);\
  19.     if (c == '\n') if (PORT(port)->lno > 1) PORT(port)->lno--;\
  20. }
  21.  
  22. #define Tweak_Stream(f) {if (!str && (feof (f) || ferror (f))) clearerr (f);}
  23.  
  24. #define Octal(c) ((c) >= '0' && (c) <= '7')
  25.  
  26. Object General_Read(), Read_Sequence(), Read_Atom(), Read_Special();
  27. Object Read_String(), Read_Sharp();
  28.  
  29. Init_Read () {
  30.     Define_Symbol (&Sym_Quote, "quote");
  31.     Define_Symbol (&Sym_Quasiquote, "quasiquote");
  32.     Define_Symbol (&Sym_Unquote, "unquote");
  33.     Define_Symbol (&Sym_Unquote_Splicing, "unquote-splicing");
  34. }
  35.  
  36. String_Getc (port) Object port; {
  37.     register struct S_Port *p;
  38.     register struct S_String *s;
  39.  
  40.     p = PORT(port);
  41.     if (p->flags & P_UNREAD) {
  42.     p->flags &= ~P_UNREAD;
  43.     return p->unread;
  44.     }
  45.     s = STRING(p->name);
  46.     return p->ptr >= s->size ? EOF : s->data[p->ptr++];
  47. }
  48.  
  49. String_Ungetc (port, c) Object port; register c; {
  50.     PORT(port)->flags |= P_UNREAD;
  51.     PORT(port)->unread = c;
  52. }
  53.  
  54. Check_Input_Port (port) Object port; {
  55.     Check_Type (port, T_Port);
  56.     if (!(PORT(port)->flags & P_OPEN))
  57.     Primitive_Error ("port has been closed: ~s", port);
  58.     if (!IS_INPUT(port))
  59.     Primitive_Error ("not an input port: ~s", port);
  60. }
  61.  
  62. Object P_Clear_Input_Port (argc, argv) Object *argv; {
  63.     Discard_Input (argc == 1 ? argv[0] : Curr_Input_Port);
  64.     return Void;
  65. }
  66.  
  67. Discard_Input (port) Object port; {
  68.     register FILE *f;
  69.  
  70.     Check_Input_Port (port);
  71.     if (PORT(port)->flags & P_STRING)
  72.     return;
  73.     f = PORT(port)->file;
  74.     f->_cnt = 0;
  75.     f->_ptr = f->_base;
  76. }
  77.  
  78. Object P_Unread_Char (argc, argv) Object *argv; {
  79.     Object port, ch;
  80.     register struct S_Port *p;
  81.  
  82.     ch = argv[0];
  83.     Check_Type (ch, T_Character);
  84.     port = argc == 2 ? argv[1] : Curr_Input_Port;
  85.     Check_Input_Port (port);
  86.     p = PORT(port);
  87.     if (p->flags & P_STRING) {
  88.     if (p->flags & P_UNREAD)
  89.         Primitive_Error ("cannot push back more than one char");
  90.     String_Ungetc (port, CHAR(ch));    
  91.     } else {
  92.     if (ungetc (CHAR(ch), p->file) == EOF)
  93.         Primitive_Error ("failed to push back char");
  94.     }
  95.     if (PORT(port)->lno > 1) PORT(port)->lno--;
  96.     return ch;
  97. }
  98.  
  99. Object P_Read_Char (argc, argv) Object *argv; {
  100.     Object port;
  101.     register FILE *f;
  102.     register c, str, flags;
  103.  
  104.     port = argc == 1 ? argv[0] : Curr_Input_Port;
  105.     Check_Input_Port (port);
  106.     f = PORT(port)->file;
  107.     flags = PORT(port)->flags;
  108.     str = flags & P_STRING;
  109.     GETC;
  110.     Tweak_Stream (f);
  111.     return c == EOF ? Eof : Make_Char (c);
  112. }
  113.  
  114. Object P_Peek_Char (argc, argv) Object *argv; {
  115.     Object a[2];
  116.  
  117.     a[0] = P_Read_Char (argc, argv);
  118.     if (argc == 1)
  119.     a[1] = argv[0];
  120.     return EQ(a[0], Eof) ? Eof : P_Unread_Char (argc+1, a);
  121. }
  122.  
  123. Object P_Read_String (argc, argv) Object *argv; {
  124.     Object port;
  125.     register FILE *f;
  126.     register c, str;
  127.     register char *p;
  128.     char buf[MAX_READ_STRING];
  129.  
  130.     port = argc == 1 ? argv[0] : Curr_Input_Port;
  131.     Check_Input_Port (port);
  132.     f = PORT(port)->file;
  133.     str = PORT(port)->flags & P_STRING;
  134.     p = buf;
  135.     while (1) {
  136.     GETC;
  137.     if (c == '\n' || c == EOF)
  138.         break;
  139.     if (p == buf+MAX_READ_STRING)
  140.         break;
  141.     *p++ = c;
  142.     }
  143.     Tweak_Stream (f);
  144.     return c == EOF ? Eof : Make_String (buf, p-buf);
  145. }
  146.  
  147. Object P_Read (argc, argv) Object *argv; {
  148.     return General_Read (argc == 1 ? argv[0] : Curr_Input_Port, 0);
  149. }
  150.  
  151. Object General_Read (port, konst) Object port; {
  152.     register FILE *f;
  153.     register c, str;
  154.     Object ret;
  155.  
  156.     Check_Input_Port (port);
  157.     Flush_Output (Curr_Output_Port);
  158.     f = PORT(port)->file;
  159.     str = PORT(port)->flags & P_STRING;
  160.     while (1) {
  161.     GETC;
  162.     if (c == EOF) {
  163.         ret = Eof;
  164.         break;
  165.     }
  166.     if (Whitespace (c))
  167.         continue;
  168.     if (c == ';') {
  169. comment:
  170.         if (Skip_Comment (port) == EOF) {
  171.         ret = Eof;
  172.         break;
  173.         }
  174.         continue;
  175.     }
  176.     if (c == '(') {
  177.         ret = Read_Sequence (port, 0, konst);
  178.     } else if (c == '#') {
  179.         ret = Read_Sharp (port, konst);
  180.         if (TYPE(ret) == T_Special)      /* it was a #! */
  181.         goto comment;
  182.     } else {
  183.         UNGETC;
  184.         ret = Read_Atom (port, konst);
  185.     }
  186.     break;
  187.     }
  188.     Tweak_Stream (f);
  189.     return ret;
  190. }
  191.  
  192. Skip_Comment (port) Object port; {
  193.     register FILE *f;
  194.     register c, str;
  195.  
  196.     f = PORT(port)->file;
  197.     str = PORT(port)->flags & P_STRING;
  198.     do {
  199.     GETC;
  200.     } while (c != '\n' && c != EOF);
  201.     return c;
  202. }
  203.  
  204. Object Read_Atom (port, konst) Object port; {
  205.     Object ret;
  206.  
  207.     ret = Read_Special (port, konst);
  208.     if (TYPE(ret) == T_Special)
  209.     Reader_Error (port, "syntax error");
  210.     return ret;
  211. }
  212.  
  213. Object Read_Special (port, konst) Object port; {
  214.     Object ret;
  215.     register c, str;
  216.     register FILE *f;
  217.     char buf[MAX_READ_SYMBOL+1];
  218.     register char *p = buf;
  219.  
  220. #define READ_QUOTE(sym) \
  221.     ( ret = Read_Atom (port, konst),\
  222.       konst ? (ret = Const_Cons (ret, Null), Const_Cons (sym, ret))\
  223.        : (ret = Cons (ret, Null), Cons (sym, ret)))
  224.  
  225.     f = PORT(port)->file;
  226.     str = PORT(port)->flags & P_STRING;
  227. again:
  228.     GETC;
  229.     switch (c) {
  230.     case EOF:
  231. eof:
  232.     Tweak_Stream (f);
  233.     Reader_Error (port, "premature end of file");
  234.     case ';':
  235.     if (Skip_Comment (port) == EOF)
  236.         goto eof;
  237.     goto again;
  238.     case ')':
  239.     SET(ret, T_Special, c);
  240.     return ret;
  241.     case '(':
  242.     return Read_Sequence (port, 0, konst);
  243.     case '\'':
  244.     return READ_QUOTE(Sym_Quote);
  245.     case '`':
  246.     return READ_QUOTE(Sym_Quasiquote);
  247.     case ',':
  248.     GETC;
  249.     if (c == EOF)
  250.         goto eof;
  251.     if (c == '@') {
  252.         return READ_QUOTE(Sym_Unquote_Splicing);
  253.     } else {
  254.         UNGETC;
  255.         return READ_QUOTE(Sym_Unquote);
  256.     }
  257.     case '"':
  258.     return Read_String (port, konst);
  259.     case '#':
  260.     ret = Read_Sharp (port, konst);
  261.     if (TYPE(ret) == T_Special)
  262.         goto again;
  263.     return ret;
  264.     default:
  265.     if (Whitespace (c))
  266.         goto again;
  267.     if (c == '.') {
  268.         GETC;
  269.         if (c == EOF)
  270.         goto eof;
  271.         if (Whitespace (c)) {
  272.         UNGETC;
  273.         SET(ret, T_Special, '.');
  274.         return ret;
  275.         }
  276.         *p++ = '.';
  277.     }
  278.     while (!Whitespace (c) && !Delimiter (c) && c != EOF) {
  279.         if (p == buf+MAX_READ_SYMBOL)
  280.         Reader_Error (port, "symbol too long for reader");
  281.         if (c == '\\') {
  282.         GETC;
  283.         if (c == EOF)
  284.             break;
  285.         }
  286.         *p++ = c;
  287.         GETC;
  288.     }
  289.     *p = '\0';
  290.     if (c != EOF)
  291.         UNGETC;
  292.     ret = Parse_Number (buf, 10);
  293.     if (Nullp (ret))
  294.         ret = Intern (buf);
  295.     return ret;
  296.     }
  297.     /*NOTREACHED*/
  298. }
  299.  
  300. Object Read_Sequence (port, vec, konst) Object port; {
  301.     Object ret, e, tail, t;
  302.     GC_Node3;
  303.  
  304.     ret = tail = Null;
  305.     GC_Link3 (ret, tail, port);
  306.     while (1) {
  307.     e = Read_Special (port, konst);
  308.     if (TYPE(e) == T_Special) {
  309.         if (CHAR(e) == ')') {
  310.         GC_Unlink;
  311.         return ret;
  312.         }
  313.         if (vec)
  314.         Reader_Error (port, "wrong syntax in vector");
  315.         if (CHAR(e) == '.') {
  316.         if (Nullp (tail)) {
  317.             ret = Read_Atom (port, konst);
  318.         } else {
  319.             e = Read_Atom (port, konst);
  320.             /*
  321.              * Possibly modifying pure cons.  Must be fixed!
  322.              */
  323.             Cdr (tail) = e;
  324.         }
  325.         e = Read_Special (port, konst);
  326.         if (TYPE(e) == T_Special && CHAR(e) == ')') {
  327.             GC_Unlink;
  328.             return ret;
  329.         }
  330.         Reader_Error (port, "dot in wrong context");
  331.         }
  332.         Reader_Error (port, "syntax error");
  333.     }
  334.     if (konst) t = Const_Cons (e, Null); else t = Cons (e, Null);
  335.     if (!Nullp (tail))
  336.         /*
  337.          * Possibly modifying pure cons.  Must be fixed!
  338.          */
  339.         Cdr (tail) = t;
  340.     else
  341.         ret = t;
  342.     tail = t;
  343.     }
  344.     /*NOTREACHED*/
  345. }
  346.  
  347. Object Read_String (port, konst) Object port; {
  348.     char buf[MAX_READ_STRING];
  349.     register char *p = buf;
  350.     register FILE *f;
  351.     register n, c, oc, str;
  352.  
  353.     f = PORT(port)->file;
  354.     str = PORT(port)->flags & P_STRING;
  355.     while (1) {
  356.     GETC;
  357.     if (c == EOF) {
  358. eof:
  359.         Tweak_Stream (f);
  360.         Reader_Error (port, "end of file in string");
  361.     }
  362.     if (c == '\\') {
  363.         GETC;
  364.         switch (c) {
  365.         case EOF: goto eof;
  366.         case 'b': c = '\b'; break;
  367.         case 't': c = '\t'; break;
  368.         case 'r': c = '\r'; break;
  369.         case 'n': c = '\n'; break;
  370.         case '0': case '1': case '2': case '3':
  371.         case '4': case '5': case '6': case '7':
  372.         oc = n = 0;
  373.         do {
  374.             oc <<= 3; oc += c - '0';
  375.             GETC;
  376.             if (c == EOF) goto eof;
  377.         } while (Octal (c) && ++n <= 2);
  378.         UNGETC;
  379.         c = oc;
  380.         }
  381.     } else if (c == '"')
  382.         break;
  383.     if (p == buf+MAX_READ_STRING)
  384.         Reader_Error (port, "string too long for reader");
  385.     *p++ = c;
  386.     }
  387.     return General_Make_String (buf, p-buf, konst);
  388. }
  389.  
  390. Object Read_Sharp (port, konst) Object port; {
  391.     register c, str;
  392.     register FILE *f;
  393.     register char *p;
  394.     char buf[MAX_READ_SYMBOL+3];
  395.     Object ret;
  396.  
  397.     f = PORT(port)->file;
  398.     str = PORT(port)->flags & P_STRING;
  399.     GETC;
  400.     if (c == EOF) {
  401. eof:
  402.     Tweak_Stream (f);
  403.     Reader_Error (port, "end of file after `#'");
  404.     }
  405.     switch (c) {
  406.     case '(':
  407.     return List_To_Vector (Read_Sequence (port, 1, konst), konst);
  408.     case 'b': case 'o': case 'd': case 'x':
  409.     case 'B': case 'O': case 'D': case 'X':
  410.     p = buf; *p++ = '#'; *p++ = c;
  411.     while (1) {
  412.         GETC;
  413.         if (c == EOF)
  414.         goto eof;
  415.         if (p == buf+MAX_READ_SYMBOL+2)
  416.         Reader_Error (port, "number too long for reader");
  417.         if (Whitespace (c) || Delimiter (c))
  418.         break;
  419.         *p++ = c;
  420.     }
  421.     UNGETC;
  422.     *p = '\0';
  423.     ret = Parse_Number (buf, 10);
  424.     if (Nullp (ret))
  425.         Reader_Error (port, "radix not followed by a valid number");
  426.     return ret;
  427.     case '\\':
  428.     p = buf;
  429.     GETC;
  430.     if (c == EOF)
  431.         goto eof;
  432.     *p++ = c;
  433.     while (1) {
  434.         GETC;
  435.         if (c == EOF)
  436.         goto eof;
  437.         if (Whitespace (c) || Delimiter (c))
  438.         break;
  439.         if (p == buf+9)
  440.         goto bad;
  441.         *p++ = c;
  442.     }
  443.     UNGETC;
  444.     *p = '\0';
  445.     if (p == buf+1)
  446.         return Make_Char (*buf);
  447.     if (p == buf+3) {
  448.         for (c = 0, p = buf; p < buf+3 && Octal (*p); p++)
  449.         c = (c << 3) | (*p - '0');
  450.         if (p == buf+3)
  451.         return Make_Char (c);
  452.     }
  453.     for (p = buf; *p; p++)
  454.         if (isupper (*p))
  455.         *p = tolower (*p);
  456.     if (strcmp (buf, "space") == 0)
  457.         return Make_Char (' ');
  458.     if (strcmp (buf, "newline") == 0)
  459.         return Make_Char ('\n');
  460.     if (strcmp (buf, "return") == 0)
  461.         return Make_Char ('\r');
  462.     if (strcmp (buf, "tab") == 0)
  463.         return Make_Char ('\t');
  464.     if (strcmp (buf, "formfeed") == 0)
  465.         return Make_Char ('\f');
  466.     if (strcmp (buf, "backspace") == 0)
  467.         return Make_Char ('\b');
  468.     goto bad;
  469.     case 'f': case 'F':
  470.     return False;
  471.     case 't': case 'T':
  472.     return True;
  473.     case 'v': case 'V':
  474.     return Void;
  475.     case '!':             /* Kludge for interpreter files */
  476.     return Special;
  477.     default:
  478. bad:
  479.     Reader_Error (port, "syntax error after `#'");
  480.     }
  481.     /*NOTREACHED*/
  482. }
  483.  
  484. Object Parse_Number (buf, radix) char *buf; {
  485.     register char *p;
  486.     register c, mdigit = 0, edigit = 0, expo = 0, neg = 0, point = 0;
  487.     register i;
  488.  
  489.     if (buf[0] == '#') {
  490.     switch (buf[1]) {
  491.     case 'b': case 'B':
  492.         radix = 2; break;
  493.     case 'o': case 'O':
  494.         radix = 8; break;
  495.     case 'd': case 'D':
  496.         radix = 10; break;
  497.     case 'x': case 'X':
  498.         radix = 16; break;
  499.     default:
  500.         return Null;
  501.     }
  502.     buf += 2;
  503.     }
  504.     p = buf;
  505.     if (*p == '+' || (neg = *p == '-'))
  506.     p++;
  507.     for ( ; c = *p; p++) {
  508.     if (c == '.') {
  509.         if (expo || point++)
  510.         return Null;
  511.     } else if (radix != 16 && (c == 'e' || c == 'E')) {
  512.         if (expo++)
  513.         return Null;
  514.         if (p[1] == '+' || p[1] == '-')
  515.         p++;
  516.     } else if (radix == 16 && !index ("0123456789abcdefABCDEF", c)) {
  517.         return Null;
  518.     } else if (radix < 16 && (c < '0' || c > '0' + radix-1)) {
  519.         return Null;
  520.     } else {
  521.         if (expo) edigit++; else mdigit++;
  522.     }
  523.     }
  524.     if (!mdigit || (expo && !edigit))
  525.     return Null;
  526.     if (point || expo) {
  527.     if (radix != 10)
  528.         Primitive_Error ("reals must be given in decimal");
  529.     return Make_Reduced_Flonum (atof (buf));
  530.     }
  531.     for (i = 0, p = buf; c = *p; p++) {
  532.     if (c == '-' || c == '+') {
  533.         buf++;
  534.         continue;
  535.     }
  536.     if (radix == 16) {
  537.         if (isupper (c))
  538.         c = tolower (c);
  539.         if (c >= 'a')
  540.         c = '9' + c - 'a' + 1;
  541.     }
  542.     i = radix * i + c - '0';
  543.     if (!FIXNUM_FITS(neg ? -i : i))
  544.         return Make_Bignum (buf, neg, radix);
  545.     }
  546.     if (neg)
  547.     i = -i;
  548.     return Make_Fixnum (i);
  549. }
  550.  
  551. Reader_Error (port, msg) Object port; char *msg; {
  552.     char buf[100];
  553.  
  554.     if (PORT(port)->flags & P_STRING) {
  555.     sprintf (buf, "[string-port]: %u: %s", PORT(port)->lno, msg);
  556.     Primitive_Error (buf);
  557.     } else {
  558.     sprintf (buf, "~s: %u: %s", PORT(port)->lno, msg);
  559.     Primitive_Error (buf, PORT(port)->name);
  560.     }
  561. }
  562.